home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / heaptrk.zip / DATES.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-04  |  6KB  |  348 lines
  1. Unit Dates;
  2.  
  3. Interface
  4.   Uses crt,dos;
  5.  
  6.  
  7.  
  8. Type
  9.    DateSTr = String[12];
  10.     MonthStrg = string[10];
  11.  
  12.    Function Date : DateStr;
  13.     FUNCTION DATE_TO_DOY(DT : DATESTR) : INTEGER;
  14.     FUNCTION DOY_TO_DATE (DY : INTEGER; YEAR : INTEGER) : DATESTR;
  15.     FUNCTION STORE_DATE (DT : DATESTR) : REAL;
  16.     FUNCTION UNSTORE_DATE (DT : REAL) : DATESTR;
  17.     Function Month_Str(M : Integer) : MonthStrg;
  18.     Function Year_Num(DT : DateStr) : Integer;
  19.     Function Month_Num(DT : DateStr) : Integer;
  20.     Function Day_Num(DT : DateStr) : Integer;
  21.     Function Date_OK(Chk_Date : DateStr) : Boolean;
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28. Implementation
  29.  
  30.  
  31.  
  32. Function Date : DateStr;
  33.  
  34. Var
  35.    MnStr : String [2];
  36.     DyStr : String [2];
  37.     YrStr : String [4];
  38.    MnWrd : word;
  39.     DyWrd : word;
  40.     YrWrd : word;
  41.     WkWrd : word;
  42.  
  43. Begin
  44.  
  45.     GetDAte(YrWrd,MnWrd,DyWrd,WkWrd);
  46.  
  47.     Str(YrWrd:4,YrStr);
  48.     Str(MnWrd:2,MnStr);
  49.     If MnStr[1] = ' ' then MnStr[1] := '0';
  50.     Str(DyWrd:2,DyStr);
  51.     If DyStr[1] = ' ' then DyStr[1] := '0';
  52.    Date := MnStr+'/'+DyStr+'/'+YrStr;
  53.  
  54. End;
  55.  
  56.  
  57.  
  58. CONST
  59.  
  60.        MONTHS : ARRAY[1..12] OF INTEGER = (31,28,31,30,31,30,31,31,30,31,30,31);
  61.  
  62.  
  63.  
  64. FUNCTION DATE_TO_DOY(DT : DATESTR) : INTEGER;
  65.  
  66. VAR
  67.  
  68.    MONTH,DAY,I,DYS,CODE   : INTEGER;
  69.    YEAR              : REAL;
  70.  
  71.  
  72.  
  73. BEGIN
  74.  
  75.      DYS := 0;
  76.  
  77.      VAL(COPY(DT,1,2),MONTH,CODE);
  78.      VAL(COPY(DT,4,2),DAY,CODE);
  79.      IF LENGTH(DT) = 8 THEN VAL(COPY(DT,7,2),YEAR,CODE);
  80.      IF LENGTH(DT) =10 THEN VAL(COPY(DT,7,4),YEAR,CODE);
  81.  
  82.      FOR I:= 1 TO MONTH-1 DO BEGIN
  83.  
  84.               DYS := DYS + MONTHS[I];
  85.               IF (I = 2) AND (FRAC(YEAR/4) = 0) THEN DYS := DYS +1;
  86.  
  87.       END;
  88.  
  89.       DYS := DYS + DAY;
  90.       DATE_TO_DOY := DYS;
  91.  
  92. END;
  93.  
  94.  
  95.  
  96. FUNCTION DOY_TO_DATE (DY : INTEGER; YEAR : INTEGER) : DATESTR;
  97.  
  98.    VAR
  99.         I : INTEGER;
  100.         MN : STRING[2];
  101.         D : STRING[2];
  102.         YR : STRING[4];
  103.  
  104. BEGIN
  105.  
  106.  
  107.        I := 1;
  108.  
  109.        WHILE DY > MONTHS[I] do BEGIN
  110.  
  111.           DY := DY - MONTHS[I];
  112.           IF (I = 2) AND (FRAC(YEAR/4)=0) THEN DY := DY-1;
  113.           I := I + 1;
  114.  
  115.       END;
  116.  
  117.           STR(I:2,MN);
  118.           IF MN[1] = ' ' THEN MN[1] := '0';
  119.  
  120.           STR(DY:2,D);
  121.           IF D[1] = ' ' THEN D[1] := '0';
  122.  
  123.  
  124.           STR(YEAR:4,YR);
  125.  
  126.           IF YR[1] = ' ' THEN YR[1] := '0';
  127.           IF YR[2] = ' ' THEN YR[2] := '0';
  128.  
  129.  
  130.  
  131.           DOY_TO_DATE := MN+'/'+D+'/'+YR;
  132.  
  133. END;
  134.  
  135.  
  136.  
  137. FUNCTION STORE_DATE (DT : DATESTR) : REAL;
  138.  
  139.     VAR
  140.         SDT            : STRING [10];
  141.         YR             : REAL;
  142.         NUMBER_OF_DAYS : REAL;
  143.         I              : INTEGER;
  144.  
  145. BEGIN
  146.  
  147.     IF LENGTH(DT) = 8 THEN  SDT := COPY(DATE,7,2)+COPY(DT,7,2);
  148.     IF LENGTH(DT) = 10 THEN SDT := COPY(DT,7,4);
  149.  
  150.     VAL(SDT,YR,I);
  151.  
  152.     NUMBER_OF_DAYS := (YR*365.0)+INT(YR/4.0)+DATE_TO_DOY(DT);
  153.  
  154.  
  155.     STORE_DATE := NUMBER_OF_DAYS;
  156.  
  157. END;
  158.  
  159.  
  160.  
  161. FUNCTION UNSTORE_DATE (DT : REAL) : DATESTR;
  162.  
  163. VAR
  164.  
  165.    DAY,YR  : INTEGER;
  166.    YRR,DRR : REAL;
  167.  
  168.  
  169. BEGIN
  170.  
  171.  
  172.  
  173.       YRR := INT((DT/365.25));
  174.  
  175.  
  176.       YR  := ROUND(YRR);
  177.  
  178.  
  179.       DRR := DT-(YRR*365.0)-INT(YRR/4.0);
  180.  
  181.       DAY := ROUND(DRR);
  182.  
  183.  
  184.      UNSTORE_DATE := DOY_TO_DATE(DAY,YR);
  185.  
  186.  
  187. END;
  188.  
  189.  
  190.  
  191. Function Date_OK(Chk_Date : DateStr) : Boolean;
  192.  
  193.   Var
  194.     Month     : Integer;
  195.     Day       : Integer;
  196.     Year      : Integer;
  197.     Error     : Integer;
  198.     Leap_Year : Boolean;
  199.  
  200. Begin
  201.  
  202.     Val(Copy(Chk_Date,1,2),Month,Error);
  203.  
  204.     If Error = 0 then Val(Copy(Chk_Date,4,2),Day,Error);
  205.  
  206.     If Error = 0 then Val(Copy(Chk_Date,7,4),Year,Error);
  207.     Leap_Year :=((Error = 0) AND (Frac(Year/4) = 0));
  208.  
  209.  
  210.     Date_OK :=
  211.              (Error = 0)
  212.          AND (Length(Chk_Date) In[8,10])
  213.          AND ((Chk_Date[3] In['/','-']) AND (Chk_Date[6] In['/','-']))
  214.          AND (Month In[1..12])
  215.          AND    (((Month IN[4,6,9]) AND (Day IN[1..30]))
  216.              OR ((Month IN[1,3,5,7,8,10..12]) AND (Day IN[1..31]))
  217.              OR ((Month = 2) AND (Leap_Year) AND (Day IN[1..29]))
  218.              OR ((Month = 2) AND (Not Leap_Year) AND (Day IN[1..28])))
  219.  
  220. End;
  221.  
  222.  
  223.  
  224.  
  225.  
  226. Function Short_Date(DT : DateStr) : DateStr;
  227.  
  228.  
  229.  
  230. Begin
  231.  
  232.  
  233.       Short_Date := Copy(DT,1,6) + Copy(DT,9,2);
  234.  
  235.  
  236. End;
  237.  
  238.  
  239.  
  240. Function Month_Num(DT : DateStr) : Integer;
  241.  
  242.   Var
  243.     Err,M : Integer;
  244.  
  245. Begin
  246.  
  247.     Val(Copy(DT,1,2),M,Err);
  248.     If Err <> 0 Then
  249.      Begin
  250.       Write(#7);
  251.       Writeln;
  252.       WriteLn('Error in date ',DT);
  253.       Gotoxy(14+Err,WhereY);
  254.       Writeln(#24);
  255.       Writeln; Writeln;
  256.       Writeln('Must be in form MM/DD/YY or MM/DD/YYYY');
  257.       Halt;
  258.      End
  259.      Else
  260.  
  261.         Month_Num := M;
  262.  
  263. End;
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270. Function Day_Num(DT : DateStr) : Integer;
  271.  
  272.   Var
  273.     Err,D : Integer;
  274.  
  275. Begin
  276.  
  277.     Val(Copy(DT,4,2),D,Err);
  278.     If Err <> 0 Then
  279.      Begin
  280.       Write(#7);
  281.       Writeln;
  282.       WriteLn('Error in date ',DT);
  283.       Gotoxy(14+Err,WhereY);
  284.       Writeln(#24);
  285.       Writeln; Writeln;
  286.       Writeln('Must be in form MM/DD/YY or MM/DD/YYYY');
  287.       Halt;
  288.      End
  289.      Else
  290.  
  291.         Day_Num := D;
  292.  
  293. End;
  294.  
  295.  
  296.  
  297.  
  298.  
  299. Function Year_Num(DT : DateStr) : Integer;
  300.  
  301.   Var
  302.     Err,Y : Integer;
  303.  
  304. Begin
  305.  
  306.     Val(Copy(DT,7,4),Y,Err);
  307.     If Err <> 0 Then
  308.      Begin
  309.       Write(#7);
  310.       Writeln;
  311.       WriteLn('Error in date ',DT);
  312.       Gotoxy(14+Err,WhereY);
  313.       Writeln(#24);
  314.       Writeln; Writeln;
  315.       Writeln('Must be in form MM/DD/YY or MM/DD/YYYY');
  316.       Halt;
  317.      End
  318.      Else
  319.  
  320.         Year_Num := Y;
  321.  
  322. End;
  323.  
  324.  
  325.  
  326.  
  327.  
  328. Function Month_Str(M : Integer) : MonthStrg;
  329.  
  330.  
  331.     Type
  332.       MonthType = Array[1..12] of MonthStrg;
  333.  
  334.     Const
  335.  
  336.      Mnth : MonthType = ('January','February','March','April','May','June','July',
  337.                           'August','September','October','November','December');
  338.  
  339.  
  340.   Begin
  341.  
  342.      Month_Str := Mnth[M];
  343.  
  344.  End;
  345.  
  346.  
  347.  
  348. End.